BCI NET 2/BCI NET 2.iso/archives/programming/languages/obrn-a_1.5_lib.lha/oberon-a/source2.lha/Source/Kernel/Kernel.mod

Text File | 1995-01-26 | 41.8 KB | 1,316 lines

(**************************************************************************

     $RCSfile: Kernel.mod $
  Description: Oberon-A run-time support module.

   Created by: fjc (Frank Copeland)
    $Revision: 1.5 $
      $Author: fjc $
        $Date: 1995/01/26 00:37:31 $

  Copyright © 1994-1995, Frank Copeland.
  This file is part of Oberon-A.
  See Oberon-A.doc for conditions of use and distribution.

  Log entries are at the end of the file.
  ________________________________________________________________________

  This module has a special status in the Oberon-A system. It is always
  included in a program, even if no other module imports it. It is
  *always* the first module that gets initialised at run-time, and it is
  responsible for cleaning up the program's environment before it exits.
  Procedures in this module are called directly by the compiler to
  perform operations that are too complex to be coded inline.

  Assumptions about this module are hard-coded into the compiler, and you
  change it at your peril. Those elements that must NOT be changed will
  be clearly indicated in the associated commentary. The remaining
  elements may be modified, but you must do so with extreme care.

  This module must be a leaf module. That is, it must not import from any
  other module except SYSTEM. Any access to Amiga system software *must*
  be through variables and types declared in this module.

**************************************************************************)

<* STANDARD- *> <* MAIN- *> <* INITIALISE- *>

(* Turn off ALL compiler checks. *)

<*$ CaseChk- IndexChk- NilChk- RangeChk- StackChk- TypeChk- OvflChk- *>

(* Create selector for a debugging version *)

<* NEW DEBUG1 *> <* DEBUG1- *> (* Disabled *)

<* IF DEBUG1 THEN *>
MODULE Kernel ["LMath.o", "MarkDbg.o"];
<* ELSE *>
MODULE Kernel ["LMath.o", "Mark.o"];
<* END *>

IMPORT SYS := SYSTEM;


(*-----------------------------------------------------------------------**
** The following declarations duplicate those in modules Exec and Dos,   **
** so that there is no need to import those modules.                     **
**-----------------------------------------------------------------------*)


CONST

  memAny       = {};
  memPublic    = 0;
  memChip      = 1;
  memFast      = 2;
  memLocal     = 8;
  mem24BitDMA  = 9;
  memKick      = 10;

  memClear     = 16;
  memLargest   = 17;
  memReverse   = 18;
  memTotal     = 19;

  memNoExpunge = 31;

TYPE

  LibraryPtr = POINTER [1] TO Library;
  Library = RECORD [1] END;
  ExecBasePtr = POINTER [1] TO ExecBase;
  ExecBase = RECORD [1] (Library) END;
  PROC = PROCEDURE;
  STRPTR = POINTER [1] TO ARRAY 32767 OF CHAR;
  BSET = SYS.BYTESET;
  WSET = SYS.WORDSET;
  APTR = SYS.ADDRESS;
  UBYTE = SYS.BYTE;

  MinNodePtr = POINTER [1] TO MinNode;
  MinNode = RECORD [1]
    succ : MinNodePtr;
    pred : MinNodePtr;
  END;

  Node = RECORD [1] (MinNode)
    type : UBYTE;
    pri  : SHORTINT;
    name : STRPTR;
  END;

  MinList = RECORD [1]
    head     : MinNodePtr;
    tail     : MinNodePtr;
    tailPred : MinNodePtr;
  END;

  List = RECORD [1] (MinList)
   type     : UBYTE;
   pad      : UBYTE;
  END;

  TaskPtr = POINTER [1] TO Task;
  Task = RECORD [1] (Node)
    tcFlags    : BSET;
    state      : BSET;
    idNestCnt  : SHORTINT;
    tdNestCnt  : SHORTINT;
    sigAlloc   : SET;
    sigWait    : SET;
    sigRecvd   : SET;
    sigExcept  : SET;
    trapAlloc  : WSET;
    trapAble   : WSET;
    exceptData : APTR;
    exceptCode : PROC;
    trapData   : APTR;
    trapCode   : PROC;
    spReg      : APTR;
    spLower    : APTR;
    spUpper    : APTR;
    switch     : PROC;
    launch     : PROC;
    memEntry   : List;
    userData   : APTR;
  END;

  MsgPort = RECORD [1] (Node)
    mpFlags : BSET;
    sigBit  : SHORTINT;
    sigTask : TaskPtr;
    msgList : List;
  END;

  ProcessPtr = POINTER [1] TO Process;
  Process = RECORD [1] (Task)
    msgPort        : MsgPort;
    pad            : INTEGER;
    segList        : SYS.BPTR;
    stackSize      : LONGINT;
    globVec        : APTR;
    taskNum        : LONGINT;
    stackBase      : SYS.BPTR;
    result2        : LONGINT;
    currentDir     : SYS.BPTR;
    cis            : SYS.BPTR;
    cos            : SYS.BPTR;
    consoleTask    : APTR;
    fileSystemTask : APTR;
    cli            : SYS.BPTR;
    returnAddr     : APTR;
    pktWait        : APTR;
    windowPtr      : APTR;
    homeDir        : SYS.BPTR;
    prFlags        : SET;
    exitCode       : PROC;
    exitData       : LONGINT;
    arguments      : STRPTR;
    localVars      : MinList;
    shellPrivate   : LONGINT;
    ces            : SYS.BPTR;
  END;


(*-----------------------------------------------------------------------**
**              System library bases used by this module.                **
**-----------------------------------------------------------------------*)

CONST

  AbsExecBase = 4;

VAR

  SysBase  : ExecBasePtr;  (* Used to access exec.library functions *)

  mathBase : LibraryPtr;   (* Base pointer for math#?.library. This is
                           ** used for all REAL arithmetic.
                           *)


(*-----------------------------------------------------------------------**
** These variables are used to remember the programs initial state, so   **
** that it can be restored on exit. Do NOT make them writeable.          **
**-----------------------------------------------------------------------*)

VAR

  initialSP   : LONGINT;      (* Initial contents of A7. *)


(*-----------------------------------------------------------------------**
** These variables are used to hold the arguments passed to the program  **
** by AmigaDOS or Workbench. Do NOT make them writeable.                 **
**-----------------------------------------------------------------------*)

VAR

  fromWorkbench -: BOOLEAN;
                           (* TRUE if the program was started from
                           ** Workbench, FALSE if it was started by a
                           ** Shell or CLI.
                           *)

  dosCmdBuf     -: SYS.ADDRESS;
                           (* When started from a Shell or CLI, this
                           ** variable will hold the command line used to
                           ** run the program. Only valid if
                           ** fromWorkbench is FALSE.
                           *)

  dosCmdLen     -: LONGINT;
                           (* The length in characters of the command
                           ** line. Only valid if fromWorkbench is FALSE.
                           *)

  WBenchMsg     -: SYS.ADDRESS;
                           (* The startup message sent to the program by
                           ** Workbench. Only valid if fromWorkbench is
                           ** TRUE. This must be cast to a
                           ** Workbench.WBStartupPtr to gain access to
                           ** the arguments.
                           *)


(*-----------------------------------------------------------------------**
** The following declarations are used by the memory allocator and the   **
** garbage collector. DO NOT CHANGE THEM. See Memory.txt for a           **
** discussion of their use.                                              **
**-----------------------------------------------------------------------*)

<* IF DEBUG1 THEN *>
  CONST
    RecordBlkId = 052424C4BH; (* "RBLK" *)
    ArrayBlkId  = 041424C4BH; (* "ABLK" *)
    SysBlkId    = 053424C4BH; (* "SBLK" *)
<* END *>

TYPE

  RecordBlkPtr = POINTER [1] TO RecordBlk;
  RecordBlk = RECORD [1]
    link : SYS.ADDRESS;
    <* IF DEBUG1 THEN *>
    id   : LONGINT;
    <* END *>
    tag  : SYS.TYPETAG;
  END; (* RecordBlk *)

  ArrayBlkPtr = POINTER [1] TO ArrayBlk;
  ArrayBlk = RECORD [1]
    arrPos   : LONGINT;
    elemSize : LONGINT;
    size     : LONGINT;
    link     : SYS.ADDRESS;
    <* IF DEBUG1 THEN *>
    id       : LONGINT;
    <* END *>
    tag      : SYS.TYPETAG;
  END;

  SysBlkPtr = POINTER [1] TO SysBlk;
  SysBlk = RECORD [1]
    link : SYS.ADDRESS;
    <* IF DEBUG1 THEN *>
    id   : LONGINT;
    <* END *>
    size : LONGINT;
  END; (* SysBlk *)

  MemBlockPtr = POINTER [1] TO MemBlock;
  MemBlock = RECORD [1]
    link    : MemBlockPtr;
    <* IF DEBUG1 THEN *>
    id      : LONGINT;
    <* END *>
    sizeTag : SET;
  END;

  GCOffsetPtr = POINTER [1] TO GCOffsetBlock;
  GCOffsetBlock = RECORD [1]
    link    : GCOffsetPtr;
    varBase : SYS.ADDRESS;
  (*offsets : ARRAY OF LONGINT;*)
  END; (* GCOffsetBlock *)


(*-----------------------------------------------------------------------**
** The compiler uses the type descriptor for the following type when     **
** allocating arrays of pointers with NEW. This MUST be the first tagged **
** type declared in this module. It should also be the only one.         **
**-----------------------------------------------------------------------*)

TYPE

  PointerDesc = RECORD
    ptr : SYS.PTR
  END; (* PointerDesc *)


(*-----------------------------------------------------------------------**
** These variables are used by the memory allocator and the garbage      **
** collector.                                                            **
**-----------------------------------------------------------------------*)

VAR

  gcBase   : SYS.ADDRESS;  (* The root of the list of variable offsets
                           ** used by the mark phase of the garbage
                           ** collector.
                           *)

  traced   : SYS.ADDRESS;  (* The root of the list of traceable memory
                           ** blocks. This list is scanned by the sweep
                           ** phase of the garbage collector. This list
                           ** can contain any type of block.
                           *)

  untraced : SYS.ADDRESS;  (* The root of the list of untraced memory
                           ** blocks. These blocks are ignored by the
                           ** garbage collector. There should only be
                           ** SysBlks in this list.
                           *)


(*-----------------------------------------------------------------------**
** This variable holds a pointer to the program's Process structure.     **
**-----------------------------------------------------------------------*)

VAR

  process : ProcessPtr;


(*-----------------------------------------------------------------------**
** These types are used to implement the automatic cleanup system.       **
**-----------------------------------------------------------------------*)

TYPE

  CleanupProc * = PROCEDURE (VAR rc : LONGINT);

  CleanupPtr = POINTER [1] TO CleanupRec;
  CleanupRec = RECORD [1]
    link : CleanupPtr;
    proc : CleanupProc;
  END; (* CleanupRec *)


(*-----------------------------------------------------------------------**
** This variable is used to hold the list of installed cleanup           **
** procedures.                                                           **
**-----------------------------------------------------------------------*)

VAR

  cleanupList : CleanupPtr;


(*-----------------------------------------------------------------------**
** Variables used to install and remove a trap handler.                  **
**-----------------------------------------------------------------------*)

VAR

  userTraps   : SET;        (* The user traps allocated for the program. *)
  handlerInstalled : BOOLEAN; (* Is the handler installed? *)
  oldTrapCode : PROC;        (* The initial trap handler. *)
  oldTrapData : SYS.ADDRESS; (* The initial trap data. *)


(*-----------------------------------------------------------------------**
** Variables used to report the position of errors.                      **
**-----------------------------------------------------------------------*)

VAR

  errModule -: ARRAY 32 OF CHAR;
  errLine   -: INTEGER;
  errCol    -: INTEGER;


(*-----------------------------------------------------------------------**
** Exec library functions used by this module. Note that the parameter   **
** and return types do not exactly match the declarations in module      **
** Exec.                                                                 **
**-----------------------------------------------------------------------*)


PROCEDURE Forbid [SysBase,-132] ();
PROCEDURE AllocMem [SysBase,-198]
  ( byteSize     [0] : LONGINT;
    requirements [1] : SET )
  : SYS.ADDRESS;
PROCEDURE FreeMem [SysBase,-210]
  ( memoryBlock [9] : SYS.ADDRESS;
    byteSize    [0] : LONGINT );
PROCEDURE FindTask [SysBase,-294]
  ( name [9] : STRPTR )
  : ProcessPtr;
PROCEDURE AllocTrap [SysBase,-342]
  ( trapNum [0] : LONGINT )
  : SHORTINT;
PROCEDURE FreeTrap [SysBase,-348]
  ( trapNum [0] : LONGINT );
PROCEDURE GetMsg [SysBase,-372]
  ( VAR port [8] : MsgPort )
  : SYS.ADDRESS;
PROCEDURE ReplyMsg [SysBase,-378]
  ( message [9] : SYS.ADDRESS );
PROCEDURE WaitPort [SysBase,-384]
  ( VAR port [8] : MsgPort );
PROCEDURE OpenLibrary [SysBase,-552]
  ( libName [9] : ARRAY OF CHAR;
    version [0] : LONGINT )
  : LibraryPtr;
PROCEDURE CopyMem [SysBase,-624]
  ( source [8] : LONGINT;
    dest   [9] : LONGINT;
    size   [0] : LONGINT );


(*-----------------------------------------------------------------------*)


(* FreeMemBlock() returns a block of memory to the system. It determines
** the type of block by inspecting the type bits in the size/tag
** longword.
*)

PROCEDURE FreeMemBlock ( mem : MemBlockPtr );

  VAR size : LONGINT; sizeTag : SET;

BEGIN (* FreeMemBlock *)
  sizeTag := mem.sizeTag;
  (* Clearing bit 31 in sizeTag allows this procedure to work even if
  ** the program halts during the mark phase of the garbage collector.
  *)
  EXCL (sizeTag, 31);
  IF 0 IN sizeTag THEN (* SysBlk *)
    size := SYS.VAL (LONGINT, sizeTag) - 1;
    INC (size, SIZE (SysBlk))
  ELSIF 1 IN sizeTag THEN (* ArrayBlk *)
    DEC (SYS.VAL (LONGINT, mem), 12);
    SYS.GET (SYS.VAL (LONGINT, mem) + 8, size);
    INC (size, SIZE (ArrayBlk))
  ELSE (* RecordBlk *)
    SYS.GET (SYS.VAL (LONGINT, sizeTag), size);
    INC (size, SIZE (RecordBlk))
  END;
  FreeMem (mem, size);
END FreeMemBlock;


(* DoCleanup is responsible for any cleanup required before exiting the
** program. It is called by Halt() and TrapHandler().
*)

PROCEDURE* DoCleanup
  ( rc : LONGINT; module : STRPTR; pos : LONGINT );

  VAR mem, next : MemBlockPtr; cleanupPtr : CleanupPtr; t : LONGINT;

BEGIN (* DoCleanup *)
  IF module # NIL THEN
    COPY (module^, errModule);
    errLine := SHORT (pos DIV 10000H); errCol := SHORT (pos MOD 10000H)
  ELSE
    errModule := ""; errLine := 0; errCol := 0
  END;

  (* Execute any installed cleanup procedures. *)

  cleanupPtr := cleanupList;
  cleanupList := NIL; (* This avoids loops if an error occurs in a
                      ** cleanup procedure.
                      *)
  WHILE cleanupPtr # NIL DO
    cleanupPtr.proc (rc);
    cleanupPtr := cleanupPtr.link
  END;

  (* Free all memory allocated by the program. This must be done *after*
  ** any cleanup procedures, in case they allocate memory.
  *)

  mem := traced; traced := NIL;
  WHILE mem # NIL DO
    next := mem.link;
    FreeMemBlock (mem);
    mem := next;
  END;

  mem := untraced; untraced := NIL;
  WHILE mem # NIL DO
    next := mem.link;
    FreeMemBlock (mem);
    mem := next;
  END;

  (* This is the *last* code executed by the program. *)

  IF fromWorkbench THEN
    Forbid;              (* Stops AmigaDOS from unloading us *)
    ReplyMsg (WBenchMsg) (* Tells Workbench to do it instead *)
  END;

  SYS.SETREG (0, rc)             (* Sets return code for Dos *)
END DoCleanup;


(*-----------------------------------------------------------------------**
** The following procedures are known to the compiler. DO NOT RENAME OR  **
** REMOVE THEM. They should not be exported, but must be marked as       **
** assignable or the LongVars+ pragma switched on so that they can       **
** access global variables.                                              **
**-----------------------------------------------------------------------*)


(* Linker Symbol: "Kernel_Halt"
**
** This procedure is called as the result of a HALT or ASSERT statement,
** and also when the program exits normally by reaching the END in the
** main body of the main module. The return code is passed in register D0.
**
** Halt restores the stack pointer to the value held in the initialSP
** variable. As a result, it must not declare any local variables.
**
** The LongVars pragma is used to stop the compiler loading the module's
** global variable base into A4. As a consequence, DoCleanup() must be
** declared as PROCEDURE* (ie - assignable) so that it can access global
** variables.
*)

<*$ < LongVars+ *>
PROCEDURE Halt;

BEGIN (* Halt *)
  (* Restore initial stack pointer. *)
  SYS.SETREG (15, initialSP);
  (* Do any remaining cleanup. *)
  DoCleanup (SYS.REG (0), SYS.VAL (STRPTR, SYS.REG (8)), SYS.REG (1));
END Halt;
<*$ > *>


(* Linker symbol : Kernel_NewRecord
**
** NewRecord() is called by the compiler to implement a NEW call, when
** the parameter is a POINTER TO RECORD type.
**
** The parameter is the address of the type descriptor of the RECORD
** type.
*)

PROCEDURE* NewRecord ( tag : SYS.TYPETAG ) : SYS.PTR;

  VAR
    memBlock : RecordBlkPtr; (* Points to the allocated memory. *)
    size : LONGINT;

<*$ReturnChk-*>
BEGIN (* NewRecord *)
  memBlock := NIL;
  SYS.GET (SYS.VAL (LONGINT, tag), size);
  IF size > 0 THEN
    memBlock := AllocMem (size + SIZE (RecordBlk), {memClear});
    IF memBlock # NIL THEN
      memBlock.link := traced; traced := memBlock;
      memBlock.tag := tag;
      <* IF DEBUG1 THEN *>
      memBlock.id := RecordBlkId;
      <* END *>
      INC (SYS.VAL (LONGINT, memBlock), SIZE (RecordBlk))
    END
  END;
  RETURN SYS.VAL (SYS.PTR, memBlock)
END NewRecord;


(* Linker symbol : Kernel_NewArray
**
** NewArray() is called by the compiler to implement a NEW call, when the
** parameter is a POINTER TO ARRAY OF RECORD type.
**
** The tag parameter is the address of the type descriptor of the RECORD
** type. The size parameter is the total size of the array, calculated
** inline by the compiler.
*)

PROCEDURE* NewArray ( tag : SYS.TYPETAG; size : LONGINT ) : SYS.PTR;

  VAR memBlock : ArrayBlkPtr; (* Points to the allocated memory. *)

<*$ReturnChk-*>
BEGIN (* NewArray *)
  memBlock := NIL;
  IF size > 0 THEN
    memBlock := AllocMem (size + SIZE (ArrayBlk), {memClear});
    IF memBlock # NIL THEN
      memBlock.link := traced; traced := SYS.ADR (memBlock.link);
      memBlock.tag := SYS.VAL (SYS.TYPETAG, SYS.VAL (LONGINT, tag) + 2);
      SYS.GET (SYS.VAL (LONGINT, tag), memBlock.elemSize);
      memBlock.size := size;
      <* IF DEBUG1 THEN *>
      memBlock.id := ArrayBlkId;
      <* END *>
      INC (SYS.VAL (LONGINT, memBlock), SIZE (ArrayBlk))
    END
  END;
  RETURN SYS.VAL (SYS.PTR, memBlock)
END NewArray;


(* Linker symbol: Kernel_NewSysBlk
**
** NewSysBlk() is called by the compiler to implement a NEW or SYSTEM.NEW
** call, when an untyped memory block is required.
**
** The size parameter is the number of bytes required, and the isTraced
** parameter determines which memory list the chunk is to be linked to.
*)

PROCEDURE* NewSysBlk ( size : LONGINT; isTraced : BOOLEAN )
  : SYS.ADDRESS;

  VAR memBlock : SysBlkPtr; (* Points to the allocated memory. *)

<*$ReturnChk-*>
BEGIN (* NewSysBlk *)
  memBlock := NIL;
  IF size > 0 THEN
    (* Round size up to next multiple of 4 -- VERY IMPORTANT *)
    size := SYS.AND (size + 3, 0FFFFFFFCH);
    memBlock := AllocMem (size + SIZE (SysBlk), {memClear});
    IF memBlock # NIL THEN
      IF isTraced THEN memBlock.link := traced; traced := memBlock
      ELSE memBlock.link := untraced; untraced := memBlock;
      END;
      memBlock.size := size + 1;
      <* IF DEBUG1 THEN *>
      memBlock.id := SysBlkId;
      <* END *>
      INC (SYS.VAL (LONGINT, memBlock), SIZE (SysBlk))
    END
  END;
  RETURN memBlock
END NewSysBlk;


(* Linker symbol: Kernel_Dispose
**
** Dispose() is called by the compiler to implement a SYSTEM.DISPOSE
** call.
**
** The parameter is the address of the variable to be freed. The untraced
** and traced memory lists are searched first to determine if the
** variable points to a memory block that has been allocated by the
** program. If not, the program is HALTed with a return code of 21.
*)

PROCEDURE Dispose* ( VAR adr : SYS.ADDRESS );

  VAR mem, last, next : MemBlockPtr; size : LONGINT;

BEGIN (* Dispose *)
  mem := adr;
  IF mem # NIL THEN
    DEC (SYS.VAL (LONGINT, mem), SIZE (MemBlock));
    last := SYS.ADR (untraced); next := untraced;
    WHILE (next # NIL) & (next # mem) DO
      last := next; next := next.link
    END;
    IF next = NIL THEN
      last := SYS.ADR (traced); next := traced;
      WHILE (next # NIL) & (next # mem) DO
        last := next; next := next.link
      END;
      IF next = NIL THEN HALT (21) END
    END;
    last.link := next.link;
    FreeMemBlock (mem);
    adr := NIL
  END
END Dispose;


(* Linker symbol : Kernel_InitGC
**
** InitGC() links a module's GC offset block into a global list, which is
** traversed by the mark phase of the garbage collector. It is called
** invisibly in the module's initialisation code if it has any global
** traced pointers.
*)

<*$ < LongVars+ *>
PROCEDURE* InitGC ( offsets : GCOffsetPtr );
BEGIN (* InitGC *)
  offsets.link := gcBase; gcBase := offsets
END InitGC;
<*$ > *>


(* Linker symbol : Kernel_Move
**
** This procedure implements the SYSTEM.MOVE procedure.
*)

<*$ < LongVars+ NilChk- *>
PROCEDURE Move ( src, dst, len : LONGINT );

  VAR byte : SYS.BYTE;

BEGIN (* Move *)
  IF (src # dst) & (len > 0) THEN
    IF (dst > src) & (dst < (src + len)) THEN
      (* The blocks overlap, copy bytes from the *top* down *)
      INC (src, len); INC (dst, len);
      REPEAT
        DEC (src); DEC (dst);
        SYS.GET (src, byte); SYS.PUT (dst, byte);
        DEC (len)
      UNTIL len = 0
    ELSIF (src > dst) & (src < (dst + len)) THEN
      (* The blocks overlap, copy bytes from the *bottom* up *)
      REPEAT
        SYS.GET (src, byte); SYS.PUT (dst, byte);
        INC (src); INC (dst);
        DEC (len)
      UNTIL len = 0
    ELSE
      (* Non-overlapping blocks, let CopyMem() do it. *)
      CopyMem (src, dst, len)
    END;
  END
END Move;
<*$ > *>


(* Linker symbol : Kernel_StackChk
**
** This procedure implements stack checking for the compiler. The size of
** the additional stack required is passed in register D0.
*)

<*$ < LongVars+ EntryExitCode- *> (* Stack pragma state *)
PROCEDURE StackChk;
BEGIN (* StackChk *)
  SYS.INLINE (02F08H);    (*    MOVE.L A0, -(A7)    *)
  SYS.SETREG (8,SysBase); (*    MOVE.L SysBase,A0   *)
  SYS.INLINE (
    02068H, 00114H,       (*    MOVE.L 0114(A0), A0 *)
    02068H, 0003AH,       (*    MOVE.L 003A(A0), A0 *)
    -2E40H,               (*    ADD.L  D0, A0       *)
    041E8H, 1500,         (*    LEA    1500(A0), A0 *)
    -4E31H,               (*    CMPA.L A7,  A0      *)
    0630AH,               (*    BLS    1$           *)
    04E45H,               (*    TRAP   #5           *)
    0,0,                  (*    DC.L   moduleName   *)
    0,                    (*    DC.W   line         *)
    0,                    (*    DC.W   col          *)
    0205FH,               (* 1$ MOVE.L (A7)+, A0    *)
    04E75H                (*    RTS                 *)
  ); (* INLINE *)
END StackChk;
<*$ > *> (* Unstack pragmas *)


(*-----------------------------------------------------------------------**
** The following procedures implement REAL arithmetic. They are known to **
** the compiler and MUST NOT BE REMOVED OR RENAMED. They receive their   **
** parameters in registers. They should not be exported, or marked as    **
** assignable.                                                           **
**                                                                       **
** The REAL math routines access the mathBase variable using long        **
** addressing for efficiency. The compiler places the arguments in the   **
** appropriate registers before calling them. These are really just      **
** stubs that are used to remove the need for the compiler to know       **
** about the mathBase variable. They use JMP instead of JSR for the call **
** to save one RTS: the library function will return direct to the       **
** calling code instead of here.                                         **
**-----------------------------------------------------------------------*)

<*$ < LongVars+ *> (* Stack pragma state *)

PROCEDURE SPFix;
(* It appears to be a "feature" of the Commodore math libraries that the
** *Fix functions behave differently when used on machines with and without
** hardware FPUs. Sometimes it truncates, sometimes it rounds. Since *Fix
** cannot be relied on to truncate the result, we must do it ourselves.
*)

<*$EntryExitCode-*>
BEGIN (* SPFix *)
  SYS.INLINE (02F00H);                      (*    MOVE.L  D0,-(A7)       *)
  SYS.SETREG (14, mathBase);                (*    MOVEA.L mathBase,A6    *)
  SYS.SETREG (1, SYS.REG (0));              (*    MOVE.L  D0,D1          *)
  SYS.INLINE (4EAEH,-48);                   (*    JSR     LVOSPTst(A6)   *)
  SYS.INLINE (06C08H);                      (*    BGE     1$             *)
  SYS.INLINE (0201FH);                      (*    MOVE.L  (A7)+,D0       *)
  SYS.INLINE (4EAEH,-96);                   (*    JSR     LVOSPCeil(A6)  *)
  SYS.INLINE (06006H);                      (*    BRA.S   2$             *)
  SYS.INLINE (0201FH);                      (* 1$ MOVE.L  (A7)+,D0       *)
  SYS.INLINE (4EAEH,-90);                   (*    JSR     LVOSPFloor(A6) *)
  SYS.INLINE (4EEEH,-30);                   (* 2$ JMP     LVOSPFix(A6)   *)
END SPFix;

PROCEDURE SPFlt;
<*$EntryExitCode-*>
BEGIN (* SPFlt *)
  SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  SYS.INLINE (4EEEH,-36);                        (* JMP     LVOSPFlt(A6) *)
END SPFlt;

PROCEDURE SPCmp;
<*$EntryExitCode-*>
BEGIN (* SPCmp *)
  SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  SYS.INLINE (4EEEH,-42);                        (* JMP     LVOSPCmp(A6) *)
END SPCmp;

(* REAL is now IEEE single-precision, so this doesn't happen.
PROCEDURE SPTst;
(* MathFFP.SPTst takes its parameter in D1 instead of D0 as you would
** expect. To avoid complicating matters, the compiler passes the parameter
** in D0 anyway, and the stub copies it to D1.
*)

<*$EntryExitCode-*>
BEGIN (* SPTst *)
  SYS.SETREG (1, SYS.REG (0));                   (* MOVE.L  D0,D1        *)
  SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  SYS.INLINE (4EEEH,-48);                        (* JMP     LVOSPTst(A6) *)
END SPTst;
*)

PROCEDURE SPTst;

<*$EntryExitCode-*>
BEGIN (* SPTst *)
  SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  SYS.INLINE (4EEEH,-48);                        (* JMP     LVOSPTst(A6) *)
END SPTst;

PROCEDURE SPAbs;
<*$EntryExitCode-*>
BEGIN (* SPAbs *)
  SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  SYS.INLINE (4EEEH,-54);                        (* JMP     LVOSPAbs(A6) *)
END SPAbs;

PROCEDURE SPNeg;
<*$EntryExitCode-*>
BEGIN (* SPNeg *)
  SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  SYS.INLINE (4EEEH,-60);                        (* JMP     LVOSPNeg(A6) *)
END SPNeg;

PROCEDURE SPAdd;
<*$EntryExitCode-*>
BEGIN (* SPAdd *)
  SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  SYS.INLINE (4EEEH,-66);                        (* JMP     LVOSPAdd(A6) *)
END SPAdd;

PROCEDURE SPSub;
<*$EntryExitCode-*>
BEGIN (* SPSub *)
  SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  SYS.INLINE (4EEEH,-72);                        (* JMP     LVOSPSub(A6) *)
END SPSub;

PROCEDURE SPMul;
<*$EntryExitCode-*>
BEGIN (* SPMul *)
  SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  SYS.INLINE (4EEEH,-78);                        (* JMP     LVOSPMul(A6) *)
END SPMul;

PROCEDURE SPDiv;
<*$EntryExitCode-*>
BEGIN (* SPDiv *)
  SYS.SETREG (14, mathBase);                     (* MOVEA.L mathBase,A6  *)
  SYS.INLINE (4EEEH,-84);                        (* JMP     LVOSPDiv(A6) *)
END SPDiv;

<*$ > *> (* Unstack pragmas *)


(*-----------------------------------------------------------------------**
** Multiplication and division of 32-bit integers is done in software,   **
** in the abscence of appropriate instructions for the MC68000 CPU. The  **
** procedures that perform this task are too large to be coded inline,   **
** so they are assembled seperately to the object file "LMath.o",        **
** which is listed as an external library in the module header. See      **
** "LMath.asm" for the source code. The external declarations for these  **
** procedures are given below, purely for reference.                     **
**-----------------------------------------------------------------------*)


PROCEDURE [4] Mul32 ["Kernel_Mul32"] (l1 [0], l2 [1] : LONGINT) : LONGINT;

PROCEDURE [4] Div32 ["Kernel_Div32"] (l1 [0], l2 [1] : LONGINT) : LONGINT;


(*-----------------------------------------------------------------------**
** Procedures declared after this point are not known to the compiler.   **
**-----------------------------------------------------------------------*)


(* TrapHandler() is installed in the tcTrapCode field of the process
** structure by InstallTrapHandler(). Its job is to deal with any processor
** traps generated by the program. It is executed in supervisor mode, so it
** must do its job as quickly as possible, then get out of supervisor mode
** using an RTE instruction.
**
** The stack looks like this when TrapHandler() is called:
**
**   6(SP) - (LONG) PC when trap occurred
**   4(SP) - (WORD) SR when trap occurred
**   0(SP) - (LONG) Trap #
**
** This procedure should only concern itself with traps that are known
** to be generated by Oberon-A programs. These are traps 2..8, 10..11 and
** 32..38 (user traps 0..6). Anything else should be propagated to the
** trap handler stored in oldTrapCode.
*)

PROCEDURE* TrapHandler;

<*$ < EntryExitCode- LongVars+*>
BEGIN (* TrapHandler *)
  (* Check if the trap is ours to handle *)
  SYS.INLINE (00C97H,0,9);        (*    CMP.L  #9,(A7)         *)
  SYS.INLINE (06772H);            (*    BEQ.S  1$              *)
  SYS.INLINE (00C97H,0,2);        (*    CMP.L  #2,(A7)         *)
  SYS.INLINE (0656AH);            (*    BLO.S  1$              *)
  SYS.INLINE (00C97H,0,11);       (*    CMP.L  #11,(A7)        *)
  SYS.INLINE (06310H);            (*    BLS.S  2$              *)
  SYS.INLINE (00C97H,0,32);       (*    CMP.L  #32,(A7)        *)
  SYS.INLINE (0655AH);            (*    BLO.S  1$              *)
  SYS.INLINE (00C97H,0,38);       (*    CMP.L  #38,(A7)        *)
  SYS.INLINE (06252H);            (*    BHI.S  1$              *)

  (* It's ours *)
  (* Pop the trap number off the stack. *)
  SYS.INLINE (201FH);             (* 2$ MOVE.L (A7)+,D0        *)

  (* IF trapno IN {CHK,TRAPV,32..38}) THEN *)
  SYS.INLINE (00C80H,0,6);        (*    CMP.L  #6,D0           *)
  SYS.INLINE (06724H);            (*    BEQ.S  4$              *)
  SYS.INLINE (00C80H,0,7);        (*    CMP.L  #7,D0           *)
  SYS.INLINE (0671CH);            (*    BEQ.S  4$              *)
  SYS.INLINE (00C80H,0,32);       (*    CMP.L  #32,D0          *)
  SYS.INLINE (06522H);            (*    BLO.S  5$              *)
  SYS.INLINE (00C80H,0,38);       (*    CMP.L  #38,D0          *)
  SYS.INLINE (0621AH);            (*    BHI.S  5$              *)

  (* Get the module name and source code position. These are
  ** embedded in the object code by the compiler, immediately
  ** after the trap instruction. There is an additional short
  ** branch directly after a CHK or TRAPV instruction.
  *)

  SYS.INLINE (0226FH,2);          (*    MOVE.L 2(A7),A1        *)
  SYS.INLINE (02051H);            (*    MOVE.L (A1),A0         *)
  SYS.INLINE (02229H,4);          (*    MOVE.L 4(A1),D1        *)
  SYS.INLINE (6012H);             (*    BRA.S  $6              *)

  SYS.INLINE (0226FH,2);          (* 4$ MOVE.L 2(A7),A1        *)
  SYS.INLINE (02069H,2);          (*    MOVE.L 2(A1),A0        *)
  SYS.INLINE (02229H,6);          (*    MOVE.L 6(A1),D1        *)
  SYS.INLINE (6004H);             (*    BRA.S  $6              *)

  (* ELSE *)
  SYS.INLINE (-6E38H);            (* 5$ SUBA.L A0,A0           *)
  SYS.INLINE (07200H);            (*    MOVEQ  #0,D1           *)

  (* Add 100 to the trap number *)
  SYS.INLINE (0680H,0,100);       (* 6$ ADDI.L #100,D0         *)

  (* Replace the old PC with the address of Halt() *)
  SYS.SETREG (9, Halt);           (*    MOVE.L #Kernel_Halt,A1 *)
  SYS.INLINE (2F49H,2);           (*    MOVE.L A1,2(A7)        *)

  (* Call Halt() *)
  SYS.INLINE (4E73H);             (*    RTE                    *)

  (* Never seen it before in my life, y'honour *)
  SYS.SETREG (0, oldTrapCode);    (* 1$ MOVE.L oldTrapCode,D0  *)
  SYS.INLINE (06704H);            (*    BEQ.S  3$              *)
  SYS.INLINE (02F00H);            (*    MOVE.L D0,-(A7)        *)
  SYS.INLINE (04E75H);            (*    RTS                    *)
  SYS.INLINE (0588FH);            (* 3$ ADDQ.L #4,A7           *)
  SYS.INLINE (04E73H);            (*    RTE                    *)
END TrapHandler;
<*$ > *>

(* SetCleanup() installs a procedure that will be executed automatically
** when the program exits.
*)

PROCEDURE SetCleanup * ( proc : CleanupProc );

  VAR newCleanup : CleanupPtr;

BEGIN (* SetCleanup *)
  newCleanup := NewSysBlk (SIZE (CleanupRec), FALSE);
  IF newCleanup = NIL THEN HALT (22) END;
  newCleanup.link := cleanupList; cleanupList := newCleanup;
  newCleanup.proc := proc
END SetCleanup;


(* Size() returns the size in bytes of the record type whose type tag
** is passed as a parameter. The type tag is obtained by a call to
** SYSTEM.TAG.
*)

<*$ < LongVars+ *> (* No global variables used *)
PROCEDURE Size * ( type : SYS.TYPETAG ) : LONGINT;

  VAR size : LONGINT;

BEGIN (* Size *)
  ASSERT (type # NIL, 97);
  SYS.GET (SYS.VAL (LONGINT, type), size);
  RETURN size
END Size;
<*$ > *>


(* Name() copies the name of the type whose type tag is passed as a
** parameter into a string variable. The type tag is obtained by a call to
** SYSTEM.TAG.
**
** This procedure relies on the type tag being a pointer to a valid type
** descriptor, which has the following structure:
**
**   TypeDesc = RECORD
**     size        : LONGINT;
**     tagTable    : ARRAY 8 OF SYSTEM.TYPETAG;
**     offsetTable : ARRAY numOffsets OF LONGINT;
**     name        : ARRAY nameLen+1 OF CHAR;
**   END;
**
** The offsetTable array is terminated by a negative offset, which this
** procedure uses to find the start of the name field.
*)

<*$ < LongVars+ *> (* No global variables used *)
PROCEDURE Name * ( type : SYS.TYPETAG; VAR buf : ARRAY OF CHAR );

  VAR name : STRPTR; offset : LONGINT;

BEGIN (* Name *)
  ASSERT (type # NIL, 97);
  (* Point name at the start of the offsetTable field. *)
  name := SYS.VAL (STRPTR, SYS.VAL (LONGINT, type) + 36);
  (* Scan offsetTable until a negative offset is found *)
  REPEAT
    SYS.GET (name, offset);
    INC (SYS.VAL (LONGINT, name), 4);
  UNTIL offset < 0;
  (* name now points to the name field. *)
  COPY (name^, buf)
END Name;
<*$ > *>


(* New() allocates a new record from the type tag passed as a parameter.
** The type tag is obtained by a call to SYSTEM.TAG.
*)

PROCEDURE New * ( VAR v : SYS.PTR; type : SYS.TYPETAG );
BEGIN (* New *)
  ASSERT (type # NIL, 97);
  v := NewRecord (type)
END New;


(* Allocate() allocates a block of memory with an arbitrary size and with
** the given memory requirements. This block will be untraced, and so can
** only be referenced through an untagged pointer (system flag # [0]).
*)

PROCEDURE Allocate * ( VAR v : SYS.ADDRESS; size : LONGINT; reqs : SET );

  VAR memBlock : SysBlkPtr; (* Points to the allocated memory. *)

BEGIN (* Allocate *)
  IF size > 0 THEN
    (* Round size up to next multiple of 4 -- VERY IMPORTANT *)
    size := SYS.AND (size + 3, 0FFFFFFFCH);
    memBlock := AllocMem (size + SIZE (SysBlk), reqs);
    IF memBlock # NIL THEN
      memBlock.link := untraced; untraced := memBlock;
      memBlock.size := size + 1;
      <* IF DEBUG1 THEN *>
      memBlock.id := SysBlkId;
      <* END *>
      INC (SYS.VAL (LONGINT, memBlock), SIZE (SysBlk))
    END;
    v := memBlock
  ELSE
    v := NIL
  END
END Allocate;


(*-----------------------------------------------------------------------**
** The following procedures implement the garbage collector, which is a  **
** mark-and-sweep collector based on the algorithm described in the      **
** Oberon Technical Notes.                                               **
**-----------------------------------------------------------------------*)


(* Mark() is the heart of the garbage collector. It is written in assembly
** language for speed, but is too large to be implemented as inline code.
** Instead, it is assembled seperetely to the object file "Mark.o",
** which is listed as an external library in the module header. See
** "Mark.asm" for the source code.
*)

PROCEDURE [4] Mark ["Kernel_Mark"] ( q [8] : SYS.LONGWORD );


(* Sweep() walks the list of traced memory blocks, unmarking any marked
** blocks and freeing all unmarked blocks.
*)

PROCEDURE Sweep;

  VAR mem, prev, next : MemBlockPtr;

BEGIN (* Sweep *)
  prev := SYS.ADR (traced); next := traced;
  WHILE next # NIL DO
    IF 31 IN next.sizeTag THEN
      (* next is marked, unmark it and move on *)
      EXCL (next.sizeTag, 31);
      prev := next;
      next := next.link
    ELSE
      (* unlink the block and free it *)
      mem := next;
      next := next.link;
      prev.link := next;
      FreeMemBlock (mem)
    END
  END
END Sweep;


(*
**
*)

PROCEDURE GC*;
BEGIN (* GC *)
  SYS.SETREG (14, gcBase);
  SYS.INLINE (
    048E7H, 0000CH,          (*     MOVEM.L A4-A5, -(A7)    *)
    0200EH,                  (* G1: MOVE.L  A6, D0          *)
    06732H,                  (*     BEQ     G4              *)
    0286EH, 00004H,          (*     MOVE.L  0004(A6), A4    *)
    0508EH,                  (*     ADDQ.L  #8, A6          *)
    02E1EH,                  (* G2: MOVE.L  (A6)+, D7       *)
    06B20H,                  (*     BMI     G3              *)
    02034H, 07800H,          (*     MOVE.L  00(A4,D7.L), D0 *)
    067F6H,                  (*     BEQ     G2              *)
    02040H,                  (*     MOVE.L  D0, A0          *)
    008E8H, 7, -4,           (*     BSET    #07,  FFFC(A0)  *)
    066ECH,                  (*     BNE     G2              *)
    00828H, 0, -1,           (*     BTST    #00,  FFFF(A0)  *)
    066E4H                   (*     BNE     G2              *)
  ); (* INLINE *)
  Mark (SYS.REG (8));        (*     JSR     Kernel_Mark     *)
  SYS.INLINE (
    060DCH,                  (*     BRA     G2              *)
    -2239H,                  (* G3: ADD.L   D7, A6          *)
    0598EH,                  (*     SUBQ.L  #4, A6          *)
    02C56H,                  (*     MOVE.L  (A6), A6        *)
    060CAH,                  (*     BRA     G1              *)
    04CDFH, 03000H           (* G4: MOVEM.L (A7)+, A4-A5    *)
  ); (* INLINE *)
  Sweep;                     (*     BSR     Kernel_Sweep    *)
END GC;


(* InstallTrapHandler()
**
** Installing a trap handler makes life difficult when using a debugger or
** profiler, so this procedure is provided to allow the programmer to
** decide if the trap handler should be installed or not.
*)

PROCEDURE InstallTrapHandler*;
  VAR t : LONGINT;
BEGIN (* InstallTrapHandler *)
  IF ~handlerInstalled THEN
    (* Allocate the traps recognised by the handler *)

    userTraps := {};
    FOR t := 0 TO 6 DO
      IF AllocTrap (t) >= 0 THEN INCL (userTraps, t)
      ELSE HALT (23)
      END
    END;

    (* Replace the existing trap handler with one of our own. *)

    oldTrapCode := process.trapCode;
    oldTrapData := process.trapData;
    process.trapCode := TrapHandler;
    process.trapData := NIL;
    handlerInstalled := TRUE
  END;
END InstallTrapHandler;


(*
** RemoveTrapHandler()
**
** Removes the trap handler.
*)

PROCEDURE RemoveTrapHandler*;
  VAR t : LONGINT;
BEGIN (* RemoveTrapHandler *)
  IF handlerInstalled THEN
    FOR t := 0 TO 6 DO IF t IN userTraps THEN FreeTrap (t) END END;
    process.trapCode := oldTrapCode;
    process.trapData := oldTrapData;
    handlerInstalled := FALSE
  END
END RemoveTrapHandler;


(*-----------------------------------------------------------------------**
** This module initialisation is the first Oberon code executed by a     **
** program. It is called from a short code prologue placed at the very   **
** start of the program.                                                 **
**-----------------------------------------------------------------------*)

<*$ClearVars+*>
BEGIN (* Kernel *)

  (* Dos passes the command line and its length in A0/D0. These must be
  ** saved, as well as the initial stack pointer.
  *)

  SYS.GETREG (8, dosCmdBuf);
  SYS.GETREG (0, dosCmdLen);
  SYS.GETREG (15, initialSP);
  INC (initialSP, 4); (* Allow for the JSR that got us here. *)

  (* Get SysBase *)
  SYS.GET (AbsExecBase, SysBase);

  (* Now find our Process structure and see if we are run from the Shell
  ** or the Workbench.
  *)
  process := FindTask (NIL);
  fromWorkbench := (process.cli = NIL);

  IF fromWorkbench THEN
    (* The program was run by Workbench. We must wait for a startup
    ** message at the process message port and clear it immediately. The
    ** message must be saved, to be replied when the program exits.
    *)
    WaitPort (process.msgPort);
    WBenchMsg := GetMsg (process.msgPort);
  END;

  (* Attempt to open the math library. *)

  mathBase := OpenLibrary ("mathieeesingbas.library", 33);
  ASSERT (mathBase # NIL, 100);

  (* D1 is non-zero when the main body starts. It must be zero on exit *)
  SYS.SETREG (1, 0)
END Kernel.

(*************************************************************************

  $Log: Kernel.mod $
  Revision 1.5  1995/01/26  00:37:31  fjc
  - Release 1.5

  Revision 1.4  1995/01/09  18:25:03  fjc
  - Incorporated changes in interfaces

  Revision 1.3  1994/11/11  16:44:48  fjc
  - Uses new external code interface.

  Revision 1.2  1994/09/18  20:53:39  fjc
  - Converted switches to pragmas/options

  Revision 1.1  1994/08/22  21:50:29  fjc
  Initial revision

*************************************************************************)